home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clcs / top-patches.lisp < prev   
Lisp/Scheme  |  1991-07-08  |  7KB  |  183 lines
  1.  
  2. (in-package "CONDITIONS")
  3.  
  4. (import '(with-simple-restart abort continue compute-restarts
  5.       *debug-level* *debug-restarts* *number-of-debug-restarts*
  6.       *debug-abort* *debug-continue* *debug-condition* *debug-eval*
  7.       find-restart invoke-restart invoke-restart-interactively
  8.       restart-name ignore-errors show-restarts conditionp)
  9.     "SYSTEM")
  10.  
  11. (in-package "SYSTEM")
  12.  
  13. (defvar *abort-restarts* nil)
  14.  
  15. (defmacro with-clcs-break-level-bindings (&body forms)
  16.   `(let* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*))
  17.       (debug-level *DEBUG-LEVEL*)
  18.       (*DEBUG-RESTARTS* (COMPUTE-RESTARTS))
  19.       (*NUMBER-OF-DEBUG-RESTARTS* (LENGTH *DEBUG-RESTARTS*))
  20.       (*DEBUG-ABORT*    (FIND-RESTART 'ABORT))
  21.       (*DEBUG-CONTINUE* (OR (LET ((C (FIND-RESTART 'CONTINUE)))
  22.                   (IF (OR (NOT *DEBUG-CONTINUE*)
  23.                       (NOT (EQ *DEBUG-CONTINUE* C)))
  24.                       C NIL))
  25.                 (LET ((C (IF *DEBUG-RESTARTS*
  26.                          (FIRST *DEBUG-RESTARTS*) NIL)))
  27.                   (IF (NOT (EQ C *DEBUG-ABORT*)) C NIL))))
  28.       (*DEBUG-CONDITION* (if (conditionp at) at *DEBUG-CONDITION*))
  29.       (*abort-restarts* (let ((abort-list nil))
  30.                   (dolist (restart *DEBUG-RESTARTS*)
  31.                 (when (eq 'abort (restart-name restart))
  32.                   (push restart abort-list)))
  33.                   (nreverse abort-list))))
  34.      ,@forms))
  35.  
  36. (defun clcs-break-level-invoke-restart (-)
  37.   (COND ((AND (PLUSP -)
  38.           (< - (+ *NUMBER-OF-DEBUG-RESTARTS* 1)))
  39.      (LET ((RESTART (NTH (- - 1) *DEBUG-RESTARTS*)))
  40.        (INVOKE-RESTART-INTERACTIVELY RESTART)))
  41.     (T
  42.      (FORMAT T "~&No such restart."))))
  43.  
  44. ;; From akcl-1-530, changes marked with ;***
  45. (defun clcs-break-level (at &optional env)
  46.   (let* ((*break-message* (if (or (stringp at) (conditionp at)) ;***
  47.                   at *break-message*))  ;***
  48.      (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*)) ;***
  49.          (*quit-tag* nil)    ;***
  50.          (*break-level* (if (conditionp at) (cons t *break-level*) *break-level*))
  51.          (*ihs-base* (1+ *ihs-top*))
  52.          (*ihs-top* (1- (ihs-top)))
  53.          (*current-ihs* *ihs-top*)
  54.          (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
  55.          (*frs-top* (frs-top))
  56.          (*break-env* nil)
  57.      ;;(be *break-enable*) ;***
  58.      ;;(*break-enable*               ;***
  59.       ;;(progn                       ;***
  60.         ;;(if (stringp at) nil be))) ;***
  61.      ;;(*standard-input* *terminal-io*)
  62.          (*readtable* (or *break-readtable* *readtable*))
  63.          (*read-suppress* nil)
  64.          (+ +) (++ ++) (+++ +++)
  65.          (- -)
  66.          (* *) (** **) (*** ***)
  67.          (/ /) (// //) (/// ///)
  68.          )
  69.     ;;(terpri *error-output*)
  70.     (with-clcs-break-level-bindings ;***
  71.       (if (consp at)
  72.       (set-back at env)
  73.       (with-simple-restart (abort "Return to debug level ~D." DEBUG-LEVEL) ;***
  74.         (format *debug-io* "~&~A~2%" *break-message*) ;***
  75.         (when (> (length *link-array*) 0)
  76.           (format *debug-io* 
  77.               "Fast links are on: do (use-fast-links nil) for debugging~%"))
  78.         (set-current)        ;***
  79.         (setq *no-prompt* nil)
  80.         (show-restarts)))        ;***
  81.       (catch-fatal 1)
  82.       (setq *interrupt-enable* t)
  83.       (loop 
  84.        (setq +++ ++ ++ + + -)
  85.        (cond (*no-prompt* (setq *no-prompt* nil))
  86.          (t
  87.           (format *debug-io* "~&~a~a>~{~*>~}"
  88.               (if (stringp at) "" "dbl:")
  89.               (if (eq *package* (find-package 'user)) ""
  90.             (package-name *package*))
  91.               *break-level*)))
  92.        (unless ;***
  93.     (with-simple-restart (abort "Return to debug level ~D." DEBUG-LEVEL) ;***
  94.       (not
  95.         (catch 'step-continue
  96.           (setq - (locally (declare (notinline read))
  97.             (dbl-read *debug-io* nil *top-eof*)))
  98.           (when (eq - *top-eof*) (bye))
  99.           (let* ( break-command
  100.              (values
  101.               (multiple-value-list
  102.               (LOCALLY (declare (notinline break-call evalhook))
  103.                 (if (or (keywordp -) (integerp -)) ;***
  104.                 (setq - (cons - nil)))
  105.                 (cond ((and (consp -) (keywordp (car -)))
  106.                    (setq break-command t)
  107.                    (break-call (car -) (cdr -)))
  108.                   ((and (consp -) (integerp (car -))) ;***
  109.                    (setq break-command t) ;***
  110.                    (clcs-break-level-invoke-restart (car -))) ;***
  111.                   (t (evalhook - nil nil *break-env*))))))) ;***
  112.         (setq /// // // / / values *** ** ** * * (car /))
  113.         (fresh-line *debug-io*)
  114.         (dolist (val /)
  115.           (locally (declare (notinline prin1)) (prin1 val *debug-io*))
  116.           (terpri *debug-io*)))
  117.           nil)))            ;***
  118.         (terpri *debug-io*)
  119.         (break-current))))))
  120.  
  121. (defun clcs-terminal-interrupt (correctablep)
  122.   (if correctablep
  123.       (cerror "Continues execution." "Console interrupt.")
  124.       (error "Console interrupt -- cannot continue.")))
  125.  
  126. (defun clcs-break-quit (&optional (level 0))
  127.   (let ((abort (nth level (reverse *abort-restarts*))))
  128.     (when abort (invoke-restart-interactively abort)))
  129.   (break-current))
  130.  
  131. (setq conditions::*debugger-function* 'break-level)
  132. (setq conditions::*debug-command-prefix* "")
  133.  
  134. (defun break-resume ()
  135.   (and *debug-continue* (invoke-restart *debug-continue*)))
  136.  
  137. (putprop :r 'break-resume 'break-command)
  138. (putprop :s 'show-restarts 'break-command)
  139.  
  140. (defun break-help ()
  141.   (format *debug-io* "
  142. Break-loop Command Summary ([] indicates optional arg)
  143. --------------------------
  144.  
  145. :bl [j]     show local variables and their values, or segment of vs if compiled
  146.               in j stack frames starting at the current one.
  147. :bt [n]     BACKTRACE [n steps]
  148. :down [i]   DOWN i frames (one if no i)
  149. :env        describe ENVIRONMENT of this stack frame (for interpreted).
  150. :fr [n]     show frame n
  151. :loc [i]    return i'th local of this frame if its function is compiled (si::loc i)
  152. :r          RESUME (return from the current break loop).
  153. :up [i]     UP i frames (one if no i)
  154.  
  155. Example: print a bactrace of the last 4 frames
  156.  
  157. >>:bt 4
  158.  
  159. Note:  (use-fast-links nil) makes all non system function calls
  160. be recorded in the stack.   (use-fast-links t) is the default
  161.  
  162.  
  163. Low level commands:
  164. ------------------
  165. :p [i]           make current the i'th PREVIOUS frame (in list show by :b)
  166. :n [i]           make current the i'th NEXT frame (in list show by :b)
  167. :go [ihs-index]  make current the frame corresponding ihs-index
  168. :m               print the last break message.
  169. :s               show restarts.
  170. :c               show function of the current ihs frame.
  171. :q [i]           quit to top level
  172. :r               resume from this break loop.
  173. :b               full backtrace of all functions and special forms.
  174. :bs [name]       backward search for frame named 'name'
  175. :fs  [name]      search for frame named 'name'
  176. :vs [from] [to]  Show value stack between FROM and TO
  177. :ihs [from] [to] Show Invocation History Stack
  178. :bds ['v1 'v2 ..]Show previous special bindings of v1, v2,.. or all if no v1
  179.  
  180. ")
  181.       (values)
  182.       )
  183.